perm filename NOTWRT.F4[1,LCS]2 blob
sn#084616 filedate 1974-01-30 generic text, type T, neo UTF8
SUBROUTINE NOTWRT
IMPLICIT INTEGER(A-Q,S-Z)
COMMON/DL/IXRX,M,AA
COMMON/SCM/V(78),ISCR,LCNT,RSTF,LIST(200),REND
DIMENSION SU(250),RACNT(52),RDOT(7),XAC(6)
REAL DIS,PWDS,CENTR,POS,STFF
COMMON /STF/RSTFAC(8),RSTJC
COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
COMMON/PLTR/PLT,RHT,DIS/XRN/RN(4000)/POSI/STFF(8),JJB,POS
COMMON/NW/FILL(7),RNOTE(24)
COMMON /NU/NUMQ(44),RNUMS(327),RACCI(32),NACCI(3)
C FOR NOTE DRAWING
EQUIVALENCE (JC,JQ(1)),(JD,JQ(2)),(JE,JQ(3)),(RJD,RJQ(2))
1,(RJF,RJQ(4)),(JG,JQ(5)),(JH,JQ(6)),(JI,JQ(7)),(JJ,JQ(8))
1,(JK,JQ(9)),(JF,JQ(4)),(RJE,RJQ(3)),(SU(1),RN(3001))
1,(RJH,RJQ(6)),(RJG,RJQ(5))
DATA RACNT/4.0,1000.005,17.0,0.105, 8.0,1003.0, 7.014, 11.0
1,13. ,1000. ,0.010,14.01,14. ,17. ,1001.018,7. ,13.018,27.,
1 1004., 4.002, 6.004, 8.004,10.002,10., 8.102,6.102,4.
1,32.0,1000.0,14.0,1007.007,7.107, 43.0,1012.01,11.006,9.003
1, 7.001, 5.0, 9.002, 13.006, 15.01, 10.004, 13.009, 52.0,
1 1002.008,3.003, 5.001, 8.0, 10.0, 13.001, 15.003, 16.008/
DATA RDOT/1000.0, 0.103, 1.0, 1.103, 2.0, 2.103,0/
1 , R5/5.0/, R66/66.0/, R72/72.0/,R18/18.0/,RSTM/14.54/
1 ,XAC/9,14,18,28,33,44/
C ALL DATA NUMS OVER 90 GIVE INVISIBLE VECTORS
CC RACTX=0
CC RSTJC=RSTFAC(JC+4)
RST3=3.*RSTJC
RST4=4.*RSTJC
CC RST13=13.*RSTJC
RST7=7.*RSTJC
RSTX=RSTJC
C FOR MINIS AT 245
1 CENTR=POS-R18*RSTJC+AMOD(RJD,100.0)*RST7
C 'CENTR' IS VERTICAL PLACEMENT
IF(JA.EQ.9)GO TO 90
RMINI=RSTJC
C OR SHOULD THIS ONLY BE IN NOTES, ETC? 15/9/72
IF(JA.EQ.101)GO TO 110
RJB=JB
RINV=1
551 GO TO (11,20,30,241,50,242,70,80,90,11,30,80),JA
CC IF(JA.EQ.11)GO TO 30
IF(JA.EQ.30)GO TO 571
C FOR BEAMS.
90 CALL ITMSUB
RETURN
20 IF(JE.GT.1)RJD=RJD-2
RA=RJD
RJG=RJF*10.
C FOR DOTS
202 CALL REST
IF(JE.GT.1)GO TO 200
IF(RJG.EQ.0)RETURN
201 L=14
IF(JE)L=19
JB=JB+L*RSTJC
RJD=8.+RA
JA=6
JE=7
C IF P6=1 THE REST IS DOTTED
GO TO 1
200 JE=JE-1
C FOR MULTIPLE TAILS ON 16TH REST, ETC.
RJD=RJD+2.
RJB=RJB+RST4
GO TO 202
80 CALL SLUR
57 RETURN
C FOR TREMOLO SLASHES
571 RJB=RJB+1
RX=14.*RSTJC
RJX=CENTR+RST7
RJY=RJX-RX
IF(JE.EQ.10)GO TO 42
CALL EXCH(RJX,RJY)
RJB=RJB-RX+1
42 RX=RJB+26*RSTJC
DO 40 K=1,JF
DO 41 L=0,2
RA=L*RSTJC
CALL LINES(RJB,RJX+RA,3)
41 CALL LINES(RX,RJY+RA,2)
RJX=RJX+RST7
40 RJY=RJY+RST7
RETURN
C FOR USER-DRAWN LIBRARY OF SYMBOLS
30 CALL CLEFS
RETURN
291 RJB=RJB+8.*RSTJC
IF(RINV)CENTR=CENTR-RST3
C REMOVE '8' LATER
CENTR=CENTR+2*RSTJC
29 RJX=RJB
RJY=CENTR+RSTJC
108 CALL RDRAW(1,7.0,RDOT,RSTJC,RJX,RJY,RSTJC)
IF(JA.EQ.1.OR.RJG.GE.20.)GO TO 290
RB=POS+52.*RSTJC
IF(RJY.NE.RB)GO TO 6241
C WHERE IS RB USED LATER?
RJY=RJY-12*RSTJC
GO TO 108
C ABOVE FOR DOTS
290 RJG=RJG-10.
IF(RJG.LT.10.)GO TO 1342
RJX=RJX+RSTJC*13.
GO TO 108
C FOR LEDGER LINES
70 JK=JD
C NOTE #
170 RJW=RJB-9.*RMINI
RJZ=RJB+22.*RMINI
CC RJZ=RJB+24.*RMINI
IF(JK)GO TO 71
JX=JK
JY=13
C********* 18/9/72
GO TO 711
71 JX=-JK
JY=JK*2+3
711 RX=POS-18*RSTJC+RST7*JY
C********* 18/9/72
IF(JF)RJZ=RJZ+2*RMINI
C126 IF(PLT.EQ.-3)GO TO 1126
C FOR 2-PASS PLOTTING
C ******* ABOVE IS NOT USED, 15/9/72
CC IF(PLT.EQ.-2)PLT=-4
126 CALL LINES(RJW,RX,3)
CALL LINES(RJZ,RX,2)
CC IF(PLT.EQ.-4)PLT=-2
1126 IF(JX.EQ.1)GO TO 1122
RX=RX+RSTJC*14.
JX=JX-1
GO TO 126
1122 IF(JA.EQ.7)RETURN
JI=-1
GO TO 1121
11 STEM=JE/10
C NOTES****
C RACTX=ABS(AMOD(RJF,1.0))*10.
RJF=ABS(AMOD(RJF,1.0))*10.
C RJF WILL HAVE ACCENT CODE # (.7=DOT, ETC.)
1011 RG=19.0
KL=1
CC IF(PLT.NE.-1.OR.IXRX.NE.0)RG=14.
IF(PLT.NE.-1)RG=14.
C FOR 2-PASS PLOTTING
IF(IABS(JD).LT.100)GO TO 1221
IF(IABS(JD).LT.200)GO TO 1012
RG=24.0
KL=20
C FOR DIAMOND NOTES.
GO TO 1013
1012 RMINI=.6*RSTJC
C FOR RMINI NOTES
1013 JD=MOD(JD,100)
RJD=RJD-100.
IF(RJD.GT.160.)GO TO 1013
C FOR MINI TAILS AND ACCIS. ETC.
1221 JY=IABS(JF)
IF(JY.LT.10)GO TO 2221
C P6 FOR HOMING TO RIGHT (10) OR LEFT (20) OF STEM(10=UP, 20=DOWN)
C P6<0 = WHITE NOTE
RQ=RSTM
IF(JF)RQ=RQ+1.66
C GETS WIDTH OF NOTE DISPLACEMENT
IF(JY.EQ.20)RQ=-RQ
RJB=RJB+RQ*RMINI
2221 IF((JD.GT.1.AND.JD.LT.13).OR.JI.NE.0)GO TO 1121
C ARE THERE LEDGER LINES?
JK=(JD+1)/2-6
IF(JK)JK=-((3-JD)/2)
GO TO 170
C IF JF≠0 NOTE IS FILLED IN
1121 IF(JF.GE.0.AND.KL.EQ.1)GO TO 125
CALL RDRAW(KL,RG,RNOTE,RMINI,RJB,CENTR,RMINI)
GO TO 123
125 IF(PLT)GO TO 1251
CALL LINES(RJB,CENTR,3)
CC JK=3
RG=4.0
GO TO 1253
1251 CALL NOIR(RMINI)
GO TO 123
1253 RG=RMINI*RG
RA=RJB+RG
CC DO 1252 K=1,7,JK
DO 1252 K=1,7,3
RB=FILL(K)*RMINI
CALL LINES(RA,CENTR+RB,2)
CALL LINES(RA,CENTR-RB,2)
1252 RA=RA+RG
C ABOVE IS NEW NOTES ROUTINE
123 RJE=RJE-JE
C RJE=STEPS TO LEFT FOR ACCID. (.1=1 STEP)
IF(STEM.EQ.0)GO TO 1242
128 JG=MOD(JG,10)
RG=(JG-1)*14
IF(RG)RG=0
IF(RJH.GE.999)RJH=0
C NO EXTEN. OF STEM?
RH=RJH*RST7
C STEM EXTENSIONS ARE BY NOTE #S
IF(STEM.NE.2)GO TO 1280
RJX=RJB
C FOR STEM DOWN (=2)
RG=-RG-48.
RH=-RH
L=20
RJY=3.
RJD=RJD-3.7-RJH
C RJD IS USED IN SUBR. TAIL - RJH IS STEM EXTENSION.
RJW=-2
RA=1.
GO TO 129
C NEXT IS FOR STEM UP.
1280 RJX=RSTM
RJW=2
C FOR VERT. SPACING OF MULTIPLE TAILS
RJD=RJD-2+RJH
C 2 ABOVE AND 3.7 BEFORE ARE BECAUSE ORIG. POS. OF TAIL DRWING IS OFF.
IF(JF.NE.0)RJX=16.2
C FOR HALF NOTES
RJX=RJX*RMINI+RJB
RG=RG+48.
L=10
RJY=-3.
RA=-1.
129 RJZ=CENTR+RH+RG*RMINI
IF(RMINI.NE.RSTJC)RJW=RJW*.6
CC IF(PLT.EQ.-3)GO TO 227
CC IF(PLT.EQ.-2)PLT=-4
CALL LINES(RJX,CENTR,3)
CALL LINES(RJX,RJZ,2)
CC IF(PLT.EQ.-4)PLT=-2
227 JE=JE-L
C JE HAS ACCID. # NOW
IF(JG.EQ.0)GO TO 1242
C JUMP IF NO TAILS
127 CALL TAIL(RJX,RA,RMINI)
1028 JG=JG-1
IF(JG.EQ.0)GO TO 327
RJD=RJD+RJW
C MOVES CENTR UP OR DOWN FOR NEXT TAIL
GO TO 127
327 IF(JJ.EQ.0)GO TO 1242
RJY=RJZ-19*RSTJC
RJZ=RJZ-RST4
CC IF(RJX.NE.RJB-1)GO TO 1327
IF(RA.LT.0)GO TO 1327
C NEXT IS FOR STEM DOWN SLASH
RJY=RJZ+23*RSTJC
RJZ=RJZ+RST7
1327 RJX=RJX-RST7
CALL LINES(RJX,RJY,3)
CALL LINES(RJX+17.0*RSTJC,RJZ,2)
C FOR SLASH ON GRACE NOTE TAIL
1242 IF(RJG.LT.10.)GO TO 1342
C FOR DOTTED NOTE-- P7>9
RJX=RJB+(24.+AMOD(RJG,1.0)*59.6)*RMINI
RJY=CENTR+RSTJC
IF(MOD(JD,2).NE.0)RJY=RJY+RST7
GO TO 108
1342 RJAC=RJB
C TO SAVE POS. OF NOTE FOR ACCENT
RJB=RJB-RJE*59.6*RMINI
C TO SPACE OUT ACCIDS.
IF(RMINI.NE.RSTJC)RSTJC=.7*RSTJC
C ↑↑↑↑ ↑↑↑↑↑ WAS RMINI
C********* 18/9/72
242 IF(JE.GE.0)GO TO 2421
RINV=-RINV
JE=-JE
C NOW THAT 0 IS NOT USED FOR DOTS THE ABOVE 3 LINES COULD BE CHNGD
C********** LAST # WAS 281?
C b,#,NAT, ACC ∧, ACC >, FERMATA, DOT, REP MEAS., DASH
2421 RH=14
IF(JA.NE.6)GO TO 211
STEM=0
C FOR MISC. ITEMS
210 IF(IABS(JD).LT.100)GO TO 3241
JD=MOD(JD,100)
RSTJC=.7*RSTJC
3241 JEX=-1
C FOR 2 MARKS AT ONCE.
1241 IF(JE.GE.11)GO TO 28
GO TO (211,211,211,28,28,222,249,60,27,27),JE
RETURN
C ERROR TRAP (I.E. JE=0)
241 CALL LINES(RJB,CENTR,3)
GO TO 210
2422 IF(RJF.EQ.0)RETURN
CC2422 IF(RACTX.EQ.0)RETURN
RJB=RJAC
CC RJF=RJF+.001
JE=(RJF+.001)*100.
1249 IF(MOD(JE,10).GT.3)GO TO 249
JE=JE/10
IF(JE.GT.30)GO TO 1249
C EXTRACTS ACCENT NUMBERS FROM DECIMALS IN P6.
CC IF(RJF.LT.4.)RJF=RJF*10.
CC IF(RACTX.LT.4.)RACTX=RACTX*10.
CC IF(X.NE.0)JE=JE*10+X
CC249 RX=0
CC IF(JE.EQ.7)RX=6.7
CC IF(JE.EQ.12.OR.JE.EQ.13)RX=5
CC IF(JE.EQ.11)RX=2
CC RJB=RJB+RX*RSTJC
C ↑↑↑↑ ↑↑↑↑↑ WAS RMINI
C WHAT ABOUT MINI ACCENTS?
249 IF(JE.GT.30)GO TO 28
IF(JE.GT.10)GO TO 246
IF(JA.NE.1)GO TO 250
RH=8
RB=14.
IF((JE.NE.7.AND.JE.NE.9).OR.MOD(JD,2).EQ.0)GO TO 244
IF((STEM.LE.1.AND.JD.LT.5).OR.((STEM.EQ.2.OR.STEM.EQ.0)
1 .AND.JD.GT.9))GO TO 244
RB=21
C PUTS ACCENT DOWN OR UP 1 SPACE. AVOIDS PUTTING DOT OR DASH ON LINE
244 IF(STEM.EQ.1.OR.(STEM.EQ.0.AND.JD.LT.7))RB=-RB
IF(JE.NE.6)GO TO 245
IF(JD.LT.9.AND.STEM.EQ.2)GO TO 247
IF(JD.GT.4.AND.STEM.EQ.1)GO TO 252
245 CENTR=CENTR+RB*RSTX
250 IF(JE.GT.10.OR.JE.LT.6)GO TO 247
JA=6
IF(JE.NE.7)GO TO 253
C 7=DOT
RXX=RJB
RJB=RJB+6.7*RMINI
C CENTERS THE DOT
GO TO 29
253 IF(JE.EQ.9)GO TO 271
C 9=DASH
251 IF(RB.LT.0)RINV=-RINV
C FIX THIS!!!! FOR BOWINGS, ETC.
222 CALL FERMTA(RINV)
GO TO 5241
252 RX=POS
248 CENTR=RX
GO TO 251
246 IF(STEM.EQ.1)RB=70.
IF(STEM.EQ.2)RB=21.
C CHANGE R66 AND R72 TO NUMS WHEN RIGHT ONES ARE FOUND.
GO TO 245
247 RX=POS+R72*RSTJC
IF(JE.EQ.6.OR.JE.EQ.26)GO TO 248
C 26 IS NEW NUMB FOR FERMATA. TAKE OUT 6 EVENTUALLY.
IF(JA.EQ.1.AND.JE.GT.10.AND.CENTR.LT.RX)CENTR=RX
CC JEX=-1
28 IF(JE.LT.30)GO TO 281
JEX=MOD(JE,10)
C JEX SAVES NEXT MARK.
IF(JEX.LT.4)JEX=0
JE=JE/10
IF(JE.GT.30)RETURN
C WON'T READ 415 ETC. (CORRECT=154)
C DOES BOTTOM MARK FIRST, THEN TOP.
CALL EXCH(JEX,JE)
C PUTS UPBOW, DNBOW, ETC. ABOVE STACC., ETC.
IF(JA.EQ.1)GO TO 249
GO TO 1241
281 X=1
IF(JE.NE.4)GO TO 228
X=5
RJB=RJB+.5*RSTJC
GO TO 328
CC IF(JE.EQ.11)X=9
CC IF(JE.EQ.12)X=14
CC IF(JE.EQ.13)X=18
CC IF(JE.EQ.14)X=28
CC IF(JE.EQ.15)X=33
CC IF(JE.EQ.16)X=44
228 IF(JE.GT.10)X=XAC(JE-10)
C X IS POINTER IN RACNT ARRAY
328 RA=RMINI
C OR RSTJC?
IF(RINV.LT.0.OR.(STEM.EQ.1.AND.JE.EQ.4))RA=-RA
CALL RDRAW(X+1,RACNT(X),RACNT,RA,RJB,CENTR,RMINI)
C PTR, WDCNT, ARRAY,Y MULT,HOR ADD,VERT ADD, X,Y,MULT
C IN ARRAY, 33.012 WOULD BE X=33, Y=12. 101.123 IS X=-1, Y=-23.
GO TO 5241
4241 JJJ=JE
JE=JEX
JEX=-1
IF(JA.NE.1)GO TO 7241
IF(JE.GT.10)GO TO 246
IF(JE.EQ.7.AND.JJJ.NE.9)GO TO 249
7241 RXX=RH*RMINI
IF(STEM.EQ.1)RXX=-RXX
CENTR=CENTR+RXX
IF(JE.EQ.26)JE=6
C TEMPORARY?? FIX
GO TO 1241
C >=5, ∧=4
27 RJB=JB
271 CALL LINES(RJB,CENTR,3)
C DASHES
CALL LINES(RJB+RSTJC*14.,CENTR,2)
5241 IF(JEX.GT.0)GO TO 4241
C JEX IS FOR DOUBLE MARKS. (WHAT ABOUT DOT POSITION.)
RETURN
6241 RJB=RXX
C RESET RJB AFTER A DOT.
GO TO 5241
211 IF(JE.EQ.0)GO TO 2422
IF(JE.GT.3)GO TO 222
CC IF(PLT.EQ.-3)GO TO 2422
C FOR 2-PASS PLOTTING (-2=THIN LINES, -3=HEAVY LINES)
X=NACCI(JE)
CC IF(PLT.EQ.-2)PLT=-4
CALL RDRAW(X+1,RACCI(X),RACCI,RMINI,RJB,CENTR,RMINI)
CC IF(PLT.EQ.-4)PLT=-2
GO TO 2422
500 RJB=RJB-RST3
JJB=JJB-RSTJC*13.
C ADJUSTS POS. OF #S
JE=JE-1
GO TO 222
C NUMBERS. 5, POS, STF, NOTE #, NUM, SIZE(DECI'S)
50 RDIS=RJE
JJJ=JF
IF(RDIS.EQ.0)RDIS=1.
PUNCT=0
IF(JJJ.LT.44)GO TO 51
PUNCT=JJJ
IF(JJJ.EQ.44)JJJ=38
IF(JJJ.GE.45)JJJ=36
IF(JF.NE.46)GO TO 51
RXX=4
RJB=RJB-RXX*RSTJC
RX=16
CENTR=CENTR+RX*RSTJC
51 RX=RDIS*RSTJC
451 X=NUMQ(JJJ+1)
C X=END # OF ITEM
C X+1=1ST PART OF ITEM
CALL RDRAW(X+1,RNUMS(X),RNUMS,RX,RJB,CENTR+RST3,RX)
IF(PUNCT.EQ.0)GO TO 151
IF(PUNCT.NE.46)GO TO 351
RJB=RJB+2*RXX*RSTJC
C FOR "
651 PUNCT=0
GO TO 451
351 RXX=11
C FOR : AND ;
CENTR=CENTR+RXX*RSTJC
JJJ=38
GO TO 651
151 IF(JA.EQ.101)GO TO 1005
RETURN
110 JC=RJB
IF(JC.NE.99)GO TO 1008
CALL HYDPOG(2)
RETURN
1008 JF=0
JE=0
RSTJC=1.
C SETS UP SCALE LINES.
RJC=STFF(JC+4)+60
RJ=RJC+60
CENTR=RJC+74
CALL DPYSET(2,SU,250)
CALL DPYBRT(1)
1001 POS=RJC+64
DO 1002 MX=10,200,10
RA=RHORZ(FLOAT(MX))
RJB=RA-58
IF(MX.GT.10)GO TO 50
1005 IF(RJE.NE.0)GO TO 1007
C JUMP FOR STAFF NUMBERS
CALL LINES(RA,RJC,3)
CALL LINES(RA,RJ,2)
JF=JF+1
1002 IF(JF.EQ.10)JF=0
CALL LINES(-596.0,RJ,2)
CALL LINES(-596.0,RJC,2)
RJE=1.5
C NEXT SETS UP STAFF NUMBERS
RJB=-620.
DO 1007 K=-3,4
CENTR=STFF(K+4)+21.
JF=IABS(K)
GO TO 50
1007 CONTINUE
CALL DPYOUT(2)
CALL SETPOG(1)
RETURN
C FOR 1 OR 2 BAR REP SIGNS.
60 CALL BREP(RJB,RSTJC)
END